Amiga Format CD 41/Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso/-seriously_amiga-/programming/other/scm/slib/chez.init

Text File | 1999-04-19 | 13KB | 388 lines

;;;"chez.init" Initialization file for SLIB for Chez Scheme 5.0c -*-scheme-*-
;;; Authors: [e-mail] (Dorai Sitaram) and Aubrey Jaffer.
;;;
;;; This code is in the public domain.

; Adapted to version 5.0c by [e-mail] (John David Stone) 1997

;; The SOFTWARE-TYPE procedure returns a symbol indicating the generic
;; operating system type.  UNIX, VMS, MACOS, AMIGA and MS-DOS are
;; supported.

(define software-type
  (lambda () 'unix))

;; The SCHEME-IMPLEMENTATION-TYPE procedure returns a symbol denoting the
;; Scheme implementation that loads this file.

(define scheme-implementation-type
  (lambda () 'chez))

;;; (scheme-implementation-home-page) should return a (string) URL
;;; (Uniform Resource Locator) for this scheme implementation's home
;;; page; or false if there isn't one.

(define (scheme-implementation-home-page) #f)

;; The SCHEME-IMPLEMENTATION-VERSION procedure returns a string describing
;; the version of the Scheme implementation that loads this file.

(define scheme-implementation-version
  (lambda () "5.0c"))

;; The IMPLEMENTATION-VICINITY procedure returns a string giving the
;; pathname of the directory that includes any auxiliary files used by this
;; Scheme implementation.

(define implementation-vicinity
  (lambda () "/usr/local/chez/5.0c/"))

;; The GETENV returns the value of a shell environment variable.

;; In some implementations of Chez Scheme, this can be done with foreign
;; procedures.  However, I [JDS] am using the HP version, which does not
;; support them, so a different approach is needed.
;;
;; Here's the version that doesn't work on HPs:
;;
;; (provide-foreign-entries '("getenv"))
;;
;; (define getenv
;;   (foreign-procedure "getenv"
;;     (string) string))
;;
;; And here's a version that parses the value out of the output of the
;; /bin/env command:

(define getenv
  (lambda (env-var)
    (let ((env-port (car (process "exec /bin/env")))
          (read-line
           (lambda (source)
             (let ((next (peek-char source)))
               (if (eof-object? next)
                   next
                   (let loop ((ch (read-char source))
                              (so-far '()))
                     (if (or (eof-object? ch)
                             (char=? ch #\newline))
                         (apply string (reverse so-far))
                         (loop (read-char source) (cons ch so-far))))))))
          (position-of-copula
           (lambda (str)
             (let ((len (string-length str)))
               (do ((position 0 (+ position 1)))
                   ((or (= position len)
                        (char=? (string-ref str position) #\=))
                    position))))))
      (let loop ((equation (read-line env-port)))
        (if (eof-object? equation)
            #f
            (let ((break (position-of-copula equation))
                  (len (string-length equation)))
              (if (string=? (substring equation 0 break) env-var)
                  (if (= break len)
                      ""
                      (substring equation (+ break 1) len))
                  (loop (read-line env-port)))))))))

;; The LIBRARY-VICINITY procedure returns the pathname of the directory
;; where Scheme library functions reside.

(define library-vicinity
  (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH")
              "/usr/local/lib/slib/")))
    (lambda () library-path)))

;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.

(define home-vicinity
  (let ((home-path (getenv "HOME")))
    (lambda () home-path)))

;; The OUTPUT-PORT-WIDTH procedure returns the number of graphic characters
;; that can reliably be displayed on one line of the standard output port.

(define output-port-width
  (lambda arg
    (let ((env-width-string (getenv "COLUMNS")))
      (if (and env-width-string
               (let loop ((remaining (string-length env-width-string)))
                 (or (zero? remaining)
                     (let ((next (- remaining 1)))
                       (and (char-numeric? (string-ref env-width-string
                                                       next))
                            (loop next))))))
          (- (string->number env-width-string) 1)
          79))))

;; The OUTPUT-PORT-HEIGHT procedure returns the number of lines of text
;; that can reliably be displayed simultaneously in the standard output
;; port.

(define output-port-height
  (lambda arg
    (let ((env-height-string (getenv "LINES")))
      (if (and env-height-string
               (let loop ((remaining (string-length env-height-string)))
                 (or (zero? remaining)
                     (let ((next (- remaining 1)))
                       (and (char-numeric? (string-ref env-height-string
                                                       next))
                            (loop next))))))
          (string->number env-height-string)
          24))))

;; *FEATURES* is a list of symbols describing features of this
;; implementation; SLIB procedures sometimes consult this list to figure
;; out whether to attempt some incompletely standard operation.

(define *features*
  '(source    ; Chez Scheme can load Scheme source files, with the
          ;   command (slib:load-source "filename") -- see below.

    compiled  ; Chez Scheme can also load compiled Scheme files, with the
              ;   command (slib:load-compiled "filename") -- see below.

    char-ready? delay dynamic-wind fluid-let format
    full-continuation getenv ieee-p1178 macro multiarg/and-
    multiarg-apply pretty-print random random-inexact rationalize
    rev3-procedures rev3-report rev4-optional-procedures rev4-report
    sort string-port system transcript values with-file))

;; Version 5.0c has R4RS macros, but not defmacro.

(define *defmacros*
  (list (cons 'defmacro
          (lambda (name parms . body)
        `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
                     *defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))

(define (macroexpand-1 e)
  (if (pair? e) (let ((a (car e)))
          (cond ((symbol? a) (set! a (assq a *defmacros*))
                     (if a (apply (cdr a) (cdr e)) e))
            (else e)))
      e))

(define (macroexpand e)
  (if (pair? e) (let ((a (car e)))
          (cond ((symbol? a)
             (set! a (assq a *defmacros*))
             (if a (macroexpand (apply (cdr a) (cdr e))) e))
            (else e)))
      e))

(define base:eval eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
  (require 'defmacroexpand) (apply defmacro:expand* x '()))

;; Chez's sorting routines take parameters in the order opposite to SLIB's.
;; The following definitions override the predefined procedures with the
;; parameters-reversed versions.

(define chez:sort sort)
(define chez:sort! sort!)
(define chez:merge merge)
(define chez:merge! merge!)

(define sort
  (lambda (s p)
    (chez:sort p s)))
(define sort!
  (lambda (s p)
    (chez:sort! p s)))
(define merge
  (lambda (s1 s2 p)
    (chez:merge p s1 s2)))
(define merge!
  (lambda (s1 s2 p)
    (chez:merge! p s1 s2)))

;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A)

(define chez:format format)

(define format
  (lambda (where how . args)
    (let ((str (apply chez:format how args)))
      (cond ((not where) str)
        ((eq? where #t) (display str))
        (else (display str where))))))

;; Chez's NIL variable is bound to '(); SLIB's is bound to #F.

(define nil #f)

;; SLIB provides identifiers for the TAB (ASCII 9) and FORM-FEED (ASCII 12)
;; characters.

(define slib:tab #\tab)
(define slib:form-feed #\page)

;; The following definitions implement a few widely useful procedures that
;; Chez Scheme does not provide or provides under a different name.

;; The RENAME-FILE procedure constructs and executes a Unix mv command to
;; change the name of a file.

(define rename-file
  (lambda (src dst)
    (system (string-append "mv " src " " dst))))

;; The CURRENT-ERROR-PORT procedure returns a port to which error
;; messages are to be displayed; this is the original standard output
;; port (even if the program subsequently changes the current output port
;; somehow).

(define current-error-port
  (let ((port (current-output-port)))
    (lambda () port)))

;; SLIB provides its own version of the ERROR procedure.

(define slib:error
  (lambda args
    (let ((port (current-error-port)))
      (display "Error: " port)
      (for-each (lambda (x) (display x port)) args)
      (error #f ""))))

;; The TMPNAM procedure constructs and returns a temporary file name,
;; presumably unique and not a duplicate of one already existing.

(define tmpnam
  (let ((cntr 100))
    (lambda ()
      (set! cntr (+ 1 cntr))
      (let ((tmp (string-append "slib_" (number->string cntr))))
        (if (file-exists? tmp) (tmpnam) tmp)))))

;; The FORCE-OUTPUT requires buffered output that has been written to a
;; port to be transferred all the way out to its ultimate destination.

(define force-output flush-output)

;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE.

(define call-with-output-string
  (lambda (f)
    (let ((outsp (open-output-string)))
      (f outsp)
      (let ((s (get-output-string outsp)))
        (close-output-port outsp)
        s))))

(define call-with-input-string
  (lambda (s f)
    (let* ((insp (open-input-string s))
           (res (f insp)))
      (close-input-port insp)
      res)))

;; CHAR-CODE-LIMIT is the number of characters in the character set; only
;; non-negative integers less than CHAR-CODE-LIMIT are eligible as
;; arguments to INTEGER->CHAR.

(define char-code-limit 256)

;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number.

(if (procedure? most-positive-fixnum)
    (set! most-positive-fixnum (most-positive-fixnum)))

;; The IDENTITY procedure returns its argument without change.

(define identity
  (lambda (x) x))

;; The GENTEMP procedure generates unused symbols and marks them as
;; belonging to the SLIB package.

(define gentemp
  (let ((*gensym-counter* -1))
    (lambda ()
      (set! *gensym-counter* (+ *gensym-counter* 1))
      (string->symbol
       (string-append "slib:G" (number->string *gensym-counter*))))))

;; The IN-VICINITY procedure is simply STRING-APPEND, conventionally used
;; to attach a directory pathname to the name of a file that is expected to
;; be in that directory.

(define in-vicinity string-append)

;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined
;; to return the string ".scm".  Note, however, that ".ss" is a common Chez
;; file suffix.

(define scheme-file-suffix
  (lambda () ".scm"))

;; SLIB appropriates Chez Scheme's EVAL procedure.

(define slib:eval eval)
(define macro:eval slib:eval)

(define slib:eval-load
  (lambda (<pathname> evl)
    (if (not (file-exists? <pathname>))
        (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
    (call-with-input-file <pathname>
      (lambda (port)
        (let ((old-load-pathname *load-pathname*))
          (set! *load-pathname* <pathname>)
          (do ((o (read port) (read port)))
              ((eof-object? o))
            (evl o))
          (set! *load-pathname* old-load-pathname))))))

;; SLIB:EXIT is the implementation procedure that exits, or returns
;; if exiting is not supported.

(define slib:chez:quit
  (let ((arg (call-with-current-continuation identity)))
    (cond ((procedure? arg) arg)
      (arg (exit))
      (else (exit 1)))))

(define slib:exit
  (lambda args
    (cond ((null? args) (slib:chez:quit #t))
      ((eqv? #t (car args)) (slib:chez:quit #t))
      ((eqv? #f (car args)) (slib:chez:quit #f))
      ((zero? (car args)) (slib:chez:quit #t))
      (else (slib:chez:quit #f)))))

;; The SLIB:LOAD-SOURCE procedure, given a string argument, should attach
;; the appropriate file suffix to the string and load the file named
;; by the resulting string.

(define slib:load-source
  (lambda (f)
    (load (string-append f (scheme-file-suffix)))))

;;; defmacro:load and macro:load also need the default suffix.

(define macro:load slib:load-source)

;; The SLIB:LOAD-COMPILED procedure, given a string argument, finds and
;; loads the file, assumed to have been compiled.

(define slib:load-compiled load)

;; SLIB:LOAD can now be defined to load SLIB files.

(define slib:load slib:load-source)

;; Load the REQUIRE package.

(slib:load (in-vicinity (library-vicinity) "require"))

;; end of chez.init